home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / cfun.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-07  |  7.7 KB  |  370 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. */
  21.  
  22. /*
  23.     cfun.c
  24. */
  25.  
  26. #include "include.h"
  27.  
  28.  
  29. #define dcheck_vs do{if (vs_base < vs_org || vs_top < vs_org) error("bad vs");} while (0)
  30. #define dcheck_type(a,b) check_type(a,b) ; dcheck_vs 
  31.  
  32. #define PADDR(i) ((char *)(siSPinit->s.s_dbind->fixa.fixa_self[fix(i)]))
  33. object siSPinit,siSPmemory;
  34.  
  35. object
  36. make_cfun(self, name, data, start, size)
  37. int (*self)();
  38. object name, data;
  39. char *start;
  40. int size;
  41. {
  42.     object cf;
  43.  
  44.     cf = alloc_object(t_cfun);
  45.     cf->cf.cf_self = self;
  46.     cf->cf.cf_name = name;
  47.     cf->cf.cf_data = data;
  48.     if(data && type_of(data)==t_cfdata)
  49.       { data->cfd.cfd_start=start; 
  50.         data->cfd.cfd_size=size;}
  51.       else if(size) FEerror(0,"Bad call to make_cfun");
  52.     return(cf);
  53. }
  54. object
  55. make_sfun(name,self,argd, data)
  56. int argd,(*self)();
  57. object name, data;
  58. {object sfn;
  59.        
  60.     sfn = alloc_object(t_sfun);
  61.         if(argd >15) sfn->d.t = (int)t_gfun;
  62.     sfn->sfn.sfn_self = self;
  63.     sfn->sfn.sfn_name = name;
  64.     sfn->sfn.sfn_data = data;
  65.         sfn->sfn.sfn_argd = argd;
  66.     return(sfn);
  67. }
  68.  
  69. #define VFUN_MIN_ARGS(argd) (argd & 0xff)
  70. #define VFUN_MAX_ARGS(argd) ((argd) >> 8)
  71.  
  72. object
  73. make_vfun(name,self,argd, data)
  74. int (*self)(),argd;
  75. object name, data;
  76. {object vfn;
  77.        
  78.     vfn = alloc_object(t_vfun);
  79.     vfn->vfn.vfn_self = self;
  80.     vfn->vfn.vfn_name = name;
  81.     vfn->vfn.vfn_minargs = VFUN_MIN_ARGS(argd);
  82.         vfn->vfn.vfn_maxargs = VFUN_MAX_ARGS(argd);
  83.         vfn->vfn.vfn_data = data;
  84.     return(vfn);
  85. }
  86.  
  87. object
  88. make_cclosure_new(self, name, env, data)
  89. int (*self)();
  90. object name, env, data;
  91. {
  92.     object cc;
  93.  
  94.     cc = alloc_object(t_cclosure);
  95.     cc->cc.cc_self = self;
  96.     cc->cc.cc_name = name;
  97.     cc->cc.cc_env = env;
  98.     cc->cc.cc_data = data;
  99.     cc->cc.cc_turbo = NULL;
  100.     return(cc);
  101. }
  102.  
  103.  
  104. object
  105. make_cclosure(self, name, env, data, start, size)
  106. int (*self)();
  107. object name, env, data;
  108. char *start;
  109. int size;
  110. {
  111.     if(data && type_of(data)==t_cfdata)
  112.       { data->cfd.cfd_start=start; 
  113.         data->cfd.cfd_size=size;}
  114.       else if(size) FEerror("Bad call to make_cclosure",0);
  115.     return make_cclosure_new(self,name,env,data);
  116.  
  117. }
  118.  
  119.  
  120. siLmc() /* args: (name,address) */
  121. { dcheck_type(vs_base[0],t_symbol);
  122.   dcheck_type(vs_base[1],t_fixnum);
  123.   dcheck_type(siSPmemory->s.s_dbind,t_cfdata);
  124.   vs_base[0]=make_cclosure_new(PADDR(vs_base[1]),vs_base[0],Cnil,
  125.              siSPmemory->s.s_dbind);}
  126.  
  127. object MFsfun(sym,self,argd,data)
  128.      object sym,data;
  129.      int argd,(*self)();
  130. {object sfn;
  131.  if (type_of(sym)!=t_symbol) not_a_symbol(sym);
  132.  if (sym->s.s_sfdef != NOT_SPECIAL && sym->s.s_mflag)
  133.    sym->s.s_sfdef = NOT_SPECIAL;
  134.  sfn = make_sfun(sym,self,argd,data);
  135.  sym = clear_compiler_properties(sym,sfn);
  136.  sym->s.s_gfdef = sfn;
  137.  sym->s.s_mflag = FALSE;
  138. }
  139.  
  140. siLmfsfun() /* args: (name,address,argd) */
  141. {  dcheck_type(vs_base[1],t_fixnum);
  142.   MFsfun(vs_base[0],PADDR(vs_base[1]),fix(vs_base[2]),siSPmemory->s.s_dbind);}
  143.  
  144.  
  145. object MFvfun(sym,self,argd,data)
  146.      object sym,data;
  147.      int argd,(*self)();
  148. {object vfn;
  149.  if (type_of(sym)!=t_symbol) not_a_symbol(sym);
  150.  if (sym->s.s_sfdef != NOT_SPECIAL && sym->s.s_mflag)
  151.    sym->s.s_sfdef = NOT_SPECIAL;
  152.  dcheck_type(data,t_cfdata);
  153.  vfn = make_vfun(sym,self,argd,data);
  154.  sym = clear_compiler_properties(sym,vfn);
  155.  sym->s.s_gfdef = vfn;
  156.  sym->s.s_mflag = FALSE;
  157. }
  158.  
  159. siLmfvfun()
  160. {MFvfun(vs_base[0],PADDR(vs_base[1]),fix(vs_base[2]),siSPmemory->s.s_dbind);}
  161.  
  162.  
  163.  
  164. object MFvfun_key(sym,self,argd,data,keys)
  165.      object sym,data;
  166.      int argd,(*self)();
  167.      char *keys;
  168. {if (data) set_key_struct(keys,data);
  169.  return MFvfun(sym,self,argd,data);
  170. }
  171.  
  172. siLmfvfun_key() 
  173. {MFvfun_key(vs_base[0],PADDR(vs_base[1]),fix(vs_base[2]),siSPmemory->s.s_dbind,PADDR(vs_base[3]));}
  174.  
  175.  
  176. object MFnew(sym,self,data)
  177.      object sym,data;
  178.  int (*self)();
  179. {
  180.     object cf;
  181.  
  182.     if (type_of(sym) != t_symbol)
  183.         not_a_symbol(sym);
  184.     if (sym->s.s_sfdef != NOT_SPECIAL && sym->s.s_mflag)
  185.         sym->s.s_sfdef = NOT_SPECIAL;
  186.     cf = alloc_object(t_cfun);
  187.     cf->cf.cf_self = self;
  188.     cf->cf.cf_name = sym;
  189.     cf->cf.cf_data = data;
  190.     sym = clear_compiler_properties(sym,cf);
  191.      sym->s.s_gfdef = cf;
  192.     sym->s.s_mflag = FALSE;
  193. }
  194.  
  195. siLmf()
  196. {MFnew(vs_base[0],PADDR(vs_base[1]),siSPmemory->s.s_dbind);}
  197.  
  198.  
  199. object
  200. MF(sym, self, start, size, data)
  201. object sym;
  202. int (*self)();
  203. char *start;
  204. int size;
  205. object data;
  206. { if(data && type_of(data)==t_cfdata)
  207.       { data->cfd.cfd_start=start; 
  208.         data->cfd.cfd_size=size;}
  209.       else if(size) FEerror(0,"Bad call to make_cfun");
  210.   return(MFnew(sym,self,data));
  211. }
  212.  
  213. object
  214. MM(sym, self, start, size, data)
  215. object sym;
  216. int (*self)();
  217. char *start;
  218. int size;
  219. object data;
  220. {
  221.     object cf;
  222.  
  223.     if (type_of(sym) != t_symbol)
  224.         not_a_symbol(sym);
  225.     if (sym->s.s_sfdef != NOT_SPECIAL && sym->s.s_mflag)
  226.         sym->s.s_sfdef = NOT_SPECIAL;
  227.     cf = alloc_object(t_cfun);
  228.     cf->cf.cf_self = self;
  229.     cf->cf.cf_name = sym;
  230.     cf->cf.cf_data = data;
  231.     data->cfd.cfd_start=start; 
  232.     data->cfd.cfd_size=size;
  233.     sym =     clear_compiler_properties(sym,cf);
  234.     sym->s.s_gfdef = cf;
  235.     sym->s.s_mflag = TRUE;
  236. }
  237.  
  238. siLmm()
  239. {MM(vs_base[0],PADDR(vs_base[1]),
  240.     /* bit wasteful to pass these in just to be reset to themselves..*/
  241.     siSPmemory->s.s_dbind->cfd.cfd_start,
  242.     siSPmemory->s.s_dbind->cfd.cfd_size,
  243.     siSPmemory->s.s_dbind
  244.     );}
  245.  
  246.   
  247.  
  248. object
  249. make_function(s, f)
  250. char *s;
  251. int (*f)();
  252. {
  253.     object x;
  254.     vs_mark;
  255.  
  256.     x = make_ordinary(s);
  257.     vs_push(x);
  258.     x->s.s_gfdef = make_cfun(f, x, Cnil, NULL, 0);
  259.     x->s.s_mflag = FALSE;
  260.     vs_reset;
  261.     return(x);
  262. }
  263.  
  264. object
  265. make_si_sfun(s, f,argd)
  266. char *s;
  267. int (*f)();
  268. int argd;
  269. {  object x= make_si_ordinary(s);
  270.    x->s.s_gfdef = make_sfun( x,f,argd, Cnil);
  271.    x->s.s_mflag = FALSE;
  272.    return(x);
  273. }
  274.  
  275. object
  276. make_si_vfun1(s, f,argd)
  277. char *s;
  278. int (*f)();
  279. int argd;
  280. {  object x= make_si_ordinary(s);
  281.    x->s.s_gfdef = make_vfun( x,f,argd, Cnil);
  282.    x->s.s_mflag = FALSE;
  283.    return(x);
  284. }
  285.  
  286.  
  287. object
  288. make_si_function(s, f)
  289. char *s;
  290. int (*f)();
  291. {
  292.     object x;
  293.     vs_mark;
  294.  
  295.     x = make_si_ordinary(s);
  296.     vs_push(x);
  297.     x->s.s_gfdef = make_cfun(f, x, Cnil, NULL, 0);
  298.     x->s.s_mflag = FALSE;
  299.     vs_reset;
  300.     return(x);
  301. }
  302.  
  303.  
  304.  
  305.  
  306. object
  307. make_special_form(s, f)
  308. char *s;
  309. int (*f)();
  310. {
  311.     object x;
  312.     x = make_ordinary(s);
  313.     x->s.s_sfdef = f;
  314.     return(x);
  315. }
  316.  
  317. siLcompiled_function_name()
  318. {
  319.     check_arg(1);
  320.     switch(type_of(vs_base[0])) {
  321.     case t_cfun:
  322.     case t_sfun:
  323.     case t_vfun:
  324.     case t_cclosure:
  325.     case t_gfun:
  326.       vs_base[0] = vs_base[0]->cf.cf_name;
  327.       break;
  328.     default:
  329.       FEerror("~S is not a compiled-function.", 1, vs_base[0]);
  330. }}
  331.  
  332. turbo_closure(fun)
  333. object fun;
  334. {
  335.   object l,*block;
  336.   int n;
  337.  
  338.   if(fun->cc.cc_turbo==NULL)
  339.     {for (n = 0, l = fun->cc.cc_env;  !endp(l);  n++, l = l->c.c_cdr);
  340.      block= AR_ALLOC(alloc_contblock,(1+n),object);
  341.      *block=make_fixnum(n);
  342.      fun->cc.cc_turbo = block+1; /* equivalent to &block[1] */
  343.      for (n = 0, l = fun->cc.cc_env;  !endp(l);  n++, l = l->c.c_cdr)
  344.        fun->cc.cc_turbo[n] = l;}
  345. }
  346.  
  347. siLturbo_closure()
  348. {
  349.     check_arg(1);
  350.     if (type_of(vs_base[0]) == t_cclosure)
  351.         turbo_closure(vs_base[0]);
  352. }
  353.  
  354.  
  355.  
  356. init_cfun()
  357. {
  358.     make_si_function("COMPILED-FUNCTION-NAME",
  359.              siLcompiled_function_name);
  360.     make_si_function("TURBO-CLOSURE", siLturbo_closure);
  361.     make_si_function("MFSFUN",siLmfsfun);
  362.     make_si_function("MFVFUN",siLmfvfun);
  363.     make_si_function("MF",siLmf);
  364.     make_si_function("MFVFUN-KEY",siLmfvfun_key);
  365.     make_si_function("MM",siLmm);
  366.     make_si_function("MC",siLmc);
  367.     
  368. }
  369.  
  370.